home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / buttons.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-01-29  |  42.3 KB  |  1,568 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995,97 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit Buttons;
  11.  
  12. {$S-,W-,R-}
  13. {$C PRELOAD}
  14.  
  15. interface
  16.  
  17. uses Windows, Messages, Classes, Controls, Forms, Graphics, StdCtrls,
  18.   ExtCtrls, CommCtrl;
  19.  
  20. type
  21.   TButtonLayout = (blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom);
  22.   TButtonState = (bsUp, bsDisabled, bsDown, bsExclusive);
  23.   TButtonStyle = (bsAutoDetect, bsWin31, bsNew);
  24.   TNumGlyphs = 1..4;
  25.  
  26.   TSpeedButton = class(TGraphicControl)
  27.   private
  28.     FGroupIndex: Integer;
  29.     FGlyph: Pointer;
  30.     FDown: Boolean;
  31.     FDragging: Boolean;
  32.     FAllowAllUp: Boolean;
  33.     FLayout: TButtonLayout;
  34.     FSpacing: Integer;
  35.     FMapColors: Boolean;
  36.     FMargin: Integer;
  37.     FFlat: Boolean;
  38.     FMouseInControl: Boolean;
  39.     procedure GlyphChanged(Sender: TObject);
  40.     procedure UpdateExclusive;
  41.     function GetGlyph: TBitmap;
  42.     procedure SetGlyph(Value: TBitmap);
  43.     function GetNumGlyphs: TNumGlyphs;
  44.     procedure SetNumGlyphs(Value: TNumGlyphs);
  45.     procedure SetDown(Value: Boolean);
  46.     procedure SetFlat(Value: Boolean);
  47.     procedure SetAllowAllUp(Value: Boolean);
  48.     procedure SetGroupIndex(Value: Integer);
  49.     procedure SetLayout(Value: TButtonLayout);
  50.     procedure SetSpacing(Value: Integer);
  51.     procedure SetMargin(Value: Integer);
  52.     procedure UpdateTracking;
  53.     procedure WMLButtonDblClk(var Message: TWMLButtonDown); message WM_LBUTTONDBLCLK;
  54.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  55.     procedure CMButtonPressed(var Message: TMessage); message CM_BUTTONPRESSED;
  56.     procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
  57.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  58.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  59.     procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  60.     procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
  61.     procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  62.   protected
  63.     FState: TButtonState;
  64.     function GetPalette: HPALETTE; override;
  65.     procedure Loaded; override;
  66.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  67.       X, Y: Integer); override;
  68.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  69.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  70.       X, Y: Integer); override;
  71.     procedure Paint; override;
  72.   public
  73.     constructor Create(AOwner: TComponent); override;
  74.     destructor Destroy; override;
  75.     procedure Click; override;
  76.   published
  77.     property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;
  78.     property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
  79.     property Down: Boolean read FDown write SetDown default False;
  80.     property Caption;
  81.     property Enabled;
  82.     property Flat: Boolean read FFlat write SetFlat default False;
  83.     property Font;
  84.     property Glyph: TBitmap read GetGlyph write SetGlyph;
  85.     property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;
  86.     property MapColors: Boolean read FMapColors write FMapColors default True;
  87.     property Margin: Integer read FMargin write SetMargin default -1;
  88.     property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs default 1;
  89.     property ParentFont;
  90.     property ParentShowHint;
  91.     property ShowHint;
  92.     property Spacing: Integer read FSpacing write SetSpacing default 4;
  93.     property Visible;
  94.     property OnClick;
  95.     property OnDblClick;
  96.     property OnMouseDown;
  97.     property OnMouseMove;
  98.     property OnMouseUp;
  99.   end;
  100.  
  101.   TBitBtnKind = (bkCustom, bkOK, bkCancel, bkHelp, bkYes, bkNo, bkClose,
  102.     bkAbort, bkRetry, bkIgnore, bkAll);
  103.  
  104.   TBitBtn = class(TButton)
  105.   private
  106.     FCanvas: TCanvas;
  107.     FGlyph: Pointer;
  108.     FStyle: TButtonStyle;
  109.     FKind: TBitBtnKind;
  110.     FLayout: TButtonLayout;
  111.     FSpacing: Integer;
  112.     FMargin: Integer;
  113.     IsFocused: Boolean;
  114.     FModifiedGlyph: Boolean;
  115.  
  116.     procedure CNMeasureItem(var Message: TWMMeasureItem); message CN_MEASUREITEM;
  117.     procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
  118.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  119.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  120.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk);
  121.       message WM_LBUTTONDBLCLK;
  122.  
  123.     procedure DrawItem(const DrawItemStruct: TDrawItemStruct);
  124.     procedure SetGlyph(Value: TBitmap);
  125.     function GetGlyph: TBitmap;
  126.     function GetNumGlyphs: TNumGlyphs;
  127.     procedure SetNumGlyphs(Value: TNumGlyphs);
  128.  
  129.     procedure GlyphChanged(Sender: TObject);
  130.     function IsCustom: Boolean;
  131.     function IsCustomCaption: Boolean;
  132.     procedure SetStyle(Value: TButtonStyle);
  133.     procedure SetKind(Value: TBitBtnKind);
  134.     function GetKind: TBitBtnKind;
  135.     procedure SetLayout(Value: TButtonLayout);
  136.     procedure SetSpacing(Value: Integer);
  137.     procedure SetMargin(Value: Integer);
  138.   protected
  139.     procedure CreateHandle; override;
  140.     procedure CreateParams(var Params: TCreateParams); override;
  141.     function GetPalette: HPALETTE; override;
  142.     procedure SetButtonStyle(ADefault: Boolean); override;
  143.   public
  144.     constructor Create(AOwner: TComponent); override;
  145.     destructor Destroy; override;
  146.     procedure Click; override;
  147.   published
  148.     property Cancel stored IsCustom;
  149.     property Caption stored IsCustomCaption;
  150.     property Default stored IsCustom;
  151.     property Enabled;
  152.     property Glyph: TBitmap read GetGlyph write SetGlyph stored IsCustom;
  153.     property Kind: TBitBtnKind read GetKind write SetKind default bkCustom;
  154.     property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;
  155.     property Margin: Integer read FMargin write SetMargin default -1;
  156.     property ModalResult stored IsCustom;
  157.     property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs stored IsCustom default 1;
  158.     property ParentShowHint;
  159.     property ShowHint;
  160.     property Style: TButtonStyle read FStyle write SetStyle default bsAutoDetect;
  161.     property Spacing: Integer read FSpacing write SetSpacing default 4;
  162.     property TabOrder;
  163.     property TabStop;
  164.     property Visible;
  165.     property OnEnter;
  166.     property OnExit;
  167.   end;
  168.  
  169. function DrawButtonFace(Canvas: TCanvas; const Client: TRect;
  170.   BevelWidth: Integer; Style: TButtonStyle; IsRounded, IsDown,
  171.   IsFocused: Boolean): TRect;
  172.  
  173. implementation
  174.  
  175. uses Consts, SysUtils;
  176.  
  177. {$R BUTTONS.RES}
  178.  
  179. { TBitBtn data }
  180. var
  181.   BitBtnResNames: array[TBitBtnKind] of PChar = (
  182.     nil, 'BBOK', 'BBCANCEL', 'BBHELP', 'BBYES', 'BBNO', 'BBCLOSE',
  183.     'BBABORT', 'BBRETRY', 'BBIGNORE', 'BBALL');
  184.   BitBtnCaptions: array[TBitBtnKind] of string = (
  185.     '', SOKButton, SCancelButton, SHelpButton, SYesButton, SNoButton,
  186.     SCloseButton, SAbortButton, SRetryButton, SIgnoreButton,
  187.     SAllButton);
  188.   BitBtnModalResults: array[TBitBtnKind] of TModalResult = (
  189.     0, mrOk, mrCancel, 0, mrYes, mrNo, 0, mrAbort, mrRetry, mrIgnore,
  190.     mrAll);
  191.  
  192. var
  193.   BitBtnGlyphs: array[TBitBtnKind] of TBitmap;
  194.  
  195. { DrawButtonFace - returns the remaining usable area inside the Client rect.}
  196. function DrawButtonFace(Canvas: TCanvas; const Client: TRect;
  197.   BevelWidth: Integer; Style: TButtonStyle; IsRounded, IsDown,
  198.   IsFocused: Boolean): TRect;
  199. var
  200.   NewStyle: Boolean;
  201.   R: TRect;
  202.   DC: THandle;
  203. begin
  204.   NewStyle := ((Style = bsAutoDetect) and NewStyleControls) or (Style = bsNew);
  205.  
  206.   R := Client;
  207.   with Canvas do
  208.   begin
  209.     if NewStyle then
  210.     begin
  211.       Brush.Color := clBtnFace;
  212.       Brush.Style := bsSolid;
  213.       DC := Canvas.Handle;    { Reduce calls to GetHandle }
  214.  
  215.       if IsDown then
  216.       begin    { DrawEdge is faster than Polyline }
  217.         DrawEdge(DC, R, BDR_SUNKENINNER, BF_TOPLEFT);              { black     }
  218.         DrawEdge(DC, R, BDR_SUNKENOUTER, BF_BOTTOMRIGHT);          { btnhilite }
  219.         Dec(R.Bottom);
  220.         Dec(R.Right);
  221.         Inc(R.Top);
  222.         Inc(R.Left);
  223.         DrawEdge(DC, R, BDR_SUNKENOUTER, BF_TOPLEFT or BF_MIDDLE); { btnshadow }
  224.       end
  225.       else
  226.       begin
  227.         DrawEdge(DC, R, BDR_RAISEDOUTER, BF_BOTTOMRIGHT);          { black }
  228.         Dec(R.Bottom);
  229.         Dec(R.Right);
  230.         DrawEdge(DC, R, BDR_RAISEDINNER, BF_TOPLEFT);              { btnhilite }
  231.         Inc(R.Top);
  232.         Inc(R.Left);
  233.         DrawEdge(DC, R, BDR_RAISEDINNER, BF_BOTTOMRIGHT or BF_MIDDLE); { btnshadow }
  234.       end;
  235.     end
  236.     else
  237.     begin
  238.       Pen.Color := clWindowFrame;
  239.       Brush.Color := clBtnFace;
  240.       Brush.Style := bsSolid;
  241.       Rectangle(R.Left, R.Top, R.Right, R.Bottom);
  242.  
  243.       { round the corners - only applies to Win 3.1 style buttons }
  244.       if IsRounded then
  245.       begin
  246.         Pixels[R.Left, R.Top] := clBtnFace;
  247.         Pixels[R.Left, R.Bottom - 1] := clBtnFace;
  248.         Pixels[R.Right - 1, R.Top] := clBtnFace;
  249.         Pixels[R.Right - 1, R.Bottom - 1] := clBtnFace;
  250.       end;
  251.  
  252.       if IsFocused then
  253.       begin
  254.         InflateRect(R, -1, -1);
  255.         Brush.Style := bsClear;
  256.         Rectangle(R.Left, R.Top, R.Right, R.Bottom);
  257.       end;
  258.  
  259.       InflateRect(R, -1, -1);
  260.       if not IsDown then
  261.         Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, BevelWidth)
  262.       else
  263.       begin
  264.         Pen.Color := clBtnShadow;
  265.         PolyLine([Point(R.Left, R.Bottom - 1), Point(R.Left, R.Top),
  266.           Point(R.Right, R.Top)]);
  267.       end;
  268.     end;
  269.   end;
  270.  
  271.   Result := Rect(Client.Left + 1, Client.Top + 1,
  272.     Client.Right - 2, Client.Bottom - 2);
  273.   if IsDown then OffsetRect(Result, 1, 1);
  274. end;
  275.  
  276. function GetBitBtnGlyph(Kind: TBitBtnKind): TBitmap;
  277. begin
  278.   if BitBtnGlyphs[Kind] = nil then
  279.   begin
  280.     BitBtnGlyphs[Kind] := TBitmap.Create;
  281.     BitBtnGlyphs[Kind].LoadFromResourceName(HInstance, BitBtnResNames[Kind]);
  282.   end;
  283.   Result := BitBtnGlyphs[Kind];
  284. end;
  285.  
  286. type
  287.   TGlyphList = class(TImageList)
  288.   private
  289.     Used: TBits;
  290.     FCount: Integer;
  291.     function AllocateIndex: Integer;
  292.   public
  293.     constructor CreateSize(AWidth, AHeight: Integer);
  294.     destructor Destroy; override;
  295.     function Add(Image, Mask: TBitmap): Integer;
  296.     function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
  297.     procedure Delete(Index: Integer);
  298.     property Count: Integer read FCount;
  299.   end;
  300.  
  301.   TGlyphCache = class
  302.   private
  303.     GlyphLists: TList;
  304.   public
  305.     constructor Create;
  306.     destructor Destroy; override;
  307.     function GetList(AWidth, AHeight: Integer): TGlyphList;
  308.     procedure ReturnList(List: TGlyphList);
  309.     function Empty: Boolean;
  310.   end;
  311.  
  312.   TButtonGlyph = class
  313.   private
  314.     FOriginal: TBitmap;
  315.     FGlyphList: TGlyphList;
  316.     FIndexs: array[TButtonState] of Integer;
  317.     FTransparentColor: TColor;
  318.     FNumGlyphs: TNumGlyphs;
  319.     FOnChange: TNotifyEvent;
  320.     procedure GlyphChanged(Sender: TObject);
  321.     procedure SetGlyph(Value: TBitmap);
  322.     procedure SetNumGlyphs(Value: TNumGlyphs);
  323.     procedure Invalidate;
  324.     function CreateButtonGlyph(State: TButtonState): Integer;
  325.     procedure DrawButtonGlyph(Canvas: TCanvas; X, Y: Integer;
  326.       State: TButtonState);
  327.     procedure DrawButtonText(Canvas: TCanvas; const Caption: string;
  328.       TextBounds: TRect; State: TButtonState);
  329.     procedure CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
  330.       const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
  331.       var GlyphPos: TPoint; var TextBounds: TRect);
  332.   public
  333.     constructor Create;
  334.     destructor Destroy; override;
  335.     { return the text rectangle }
  336.     function Draw(Canvas: TCanvas; const Client: TRect;
  337.       const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
  338.       State: TButtonState): TRect;
  339.     property Glyph: TBitmap read FOriginal write SetGlyph;
  340.     property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs;
  341.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  342.   end;
  343.  
  344. { TGlyphList }
  345.  
  346. constructor TGlyphList.CreateSize(AWidth, AHeight: Integer);
  347. begin
  348.   inherited CreateSize(AWidth, AHeight);
  349.   Used := TBits.Create;
  350. end;
  351.  
  352. destructor TGlyphList.Destroy;
  353. begin
  354.   Used.Free;
  355.   inherited Destroy;
  356. end;
  357.  
  358. function TGlyphList.AllocateIndex: Integer;
  359. begin
  360.   Result := Used.OpenBit;
  361.   if Result >= Used.Size then
  362.   begin
  363.     Result := inherited Add(nil, nil);
  364.     Used.Size := Result + 1;
  365.   end;
  366.   Used[Result] := True;
  367. end;
  368.  
  369. function TGlyphList.Add(Image, Mask: TBitmap): Integer;
  370. begin
  371.   Result := AllocateIndex;
  372.   Replace(Result, Image, Mask);
  373.   Inc(FCount);
  374. end;
  375.  
  376. function TGlyphList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
  377. begin
  378.   Result := AllocateIndex;
  379.   ReplaceMasked(Result, Image, MaskColor);
  380.   Inc(FCount);
  381. end;
  382.  
  383. procedure TGlyphList.Delete(Index: Integer);
  384. begin
  385.   if Used[Index] then
  386.   begin
  387.     Dec(FCount);
  388.     Used[Index] := False;
  389.   end;
  390. end;
  391.  
  392. { TGlyphCache }
  393.  
  394. constructor TGlyphCache.Create;
  395. begin
  396.   inherited Create;
  397.   GlyphLists := TList.Create;
  398. end;
  399.  
  400. destructor TGlyphCache.Destroy;
  401. begin
  402.   GlyphLists.Free;
  403.   inherited Destroy;
  404. end;
  405.  
  406. function TGlyphCache.GetList(AWidth, AHeight: Integer): TGlyphList;
  407. var
  408.   I: Integer;
  409. begin
  410.   for I := GlyphLists.Count - 1 downto 0 do
  411.   begin
  412.     Result := GlyphLists[I];
  413.     with Result do
  414.       if (AWidth = Width) and (AHeight = Height) then Exit;
  415.   end;
  416.   Result := TGlyphList.CreateSize(AWidth, AHeight);
  417.   GlyphLists.Add(Result);
  418. end;
  419.  
  420. procedure TGlyphCache.ReturnList(List: TGlyphList);
  421. begin
  422.   if List = nil then Exit;
  423.   if List.Count = 0 then
  424.   begin
  425.     GlyphLists.Remove(List);
  426.     List.Free;
  427.   end;
  428. end;
  429.  
  430. function TGlyphCache.Empty: Boolean;
  431. begin
  432.   Result := GlyphLists.Count = 0;
  433. end;
  434.  
  435. var
  436.   GlyphCache: TGlyphCache = nil;
  437.   Pattern: TBitmap = nil;
  438.   ButtonCount: Integer = 0;
  439.  
  440. procedure CreateBrushPattern;
  441. var
  442.   X, Y: Integer;
  443. begin
  444.   Pattern := TBitmap.Create;
  445.   Pattern.Width := 8;
  446.   Pattern.Height := 8;
  447.   with Pattern.Canvas do
  448.   begin
  449.     Brush.Style := bsSolid;
  450.     Brush.Color := clBtnFace;
  451.     FillRect(Rect(0, 0, Pattern.Width, Pattern.Height));
  452.     for Y := 0 to 7 do
  453.       for X := 0 to 7 do
  454.         if (Y mod 2) = (X mod 2) then  { toggles between even/odd pixles }
  455.           Pixels[X, Y] := clBtnHighlight;     { on even/odd rows }
  456.   end;
  457. end;
  458.  
  459.  
  460. { TButtonGlyph }
  461.  
  462. constructor TButtonGlyph.Create;
  463. var
  464.   I: TButtonState;
  465. begin
  466.   inherited Create;
  467.   FOriginal := TBitmap.Create;
  468.   FOriginal.OnChange := GlyphChanged;
  469.   FTransparentColor := clOlive;
  470.   FNumGlyphs := 1;
  471.   for I := Low(I) to High(I) do
  472.     FIndexs[I] := -1;
  473.   if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
  474. end;
  475.  
  476. destructor TButtonGlyph.Destroy;
  477. begin
  478.   FOriginal.Free;
  479.   Invalidate;
  480.   if Assigned(GlyphCache) and GlyphCache.Empty then
  481.   begin
  482.     GlyphCache.Free;
  483.     GlyphCache := nil;
  484.   end;
  485.   inherited Destroy;
  486. end;
  487.  
  488. procedure TButtonGlyph.Invalidate;
  489. var
  490.   I: TButtonState;
  491. begin
  492.   for I := Low(I) to High(I) do
  493.   begin
  494.     if FIndexs[I] <> -1 then FGlyphList.Delete(FIndexs[I]);
  495.     FIndexs[I] := -1;
  496.   end;
  497.   GlyphCache.ReturnList(FGlyphList);
  498.   FGlyphList := nil;
  499. end;
  500.  
  501. procedure TButtonGlyph.GlyphChanged(Sender: TObject);
  502. begin
  503.   if Sender = FOriginal then
  504.   begin
  505.     FTransparentColor := FOriginal.TransparentColor;
  506.     Invalidate;
  507.     if Assigned(FOnChange) then FOnChange(Self);
  508.   end;
  509. end;
  510.  
  511. procedure TButtonGlyph.SetGlyph(Value: TBitmap);
  512. var
  513.   Glyphs: Integer;
  514. begin
  515.   Invalidate;
  516.   FOriginal.Assign(Value);
  517.   if (Value <> nil) and (Value.Height > 0) then
  518.   begin
  519.     FTransparentColor := Value.TransparentColor;
  520.     if Value.Width mod Value.Height = 0 then
  521.     begin
  522.       Glyphs := Value.Width div Value.Height;
  523.       if Glyphs > 4 then Glyphs := 1;
  524.       SetNumGlyphs(Glyphs);
  525.     end;
  526.   end;
  527. end;
  528.  
  529. procedure TButtonGlyph.SetNumGlyphs(Value: TNumGlyphs);
  530. begin
  531.   if (Value <> FNumGlyphs) and (Value > 0) then
  532.   begin
  533.     Invalidate;
  534.     FNumGlyphs := Value;
  535.   end;
  536. end;
  537.  
  538. function TButtonGlyph.CreateButtonGlyph(State: TButtonState): Integer;
  539. const
  540.   ROP_DSPDxax = $00E20746;
  541. var
  542.   TmpImage, DDB, MonoBmp: TBitmap;
  543.   IWidth, IHeight: Integer;
  544.   IRect, ORect: TRect;
  545.   I: TButtonState;
  546.   DestDC: HDC;
  547. begin
  548.   if (State = bsDown) and (NumGlyphs < 3) then State := bsUp;
  549.   Result := FIndexs[State];
  550.   if Result <> -1 then Exit;
  551.   if (FOriginal.Width or FOriginal.Height) = 0 then Exit;
  552.   IWidth := FOriginal.Width div FNumGlyphs;
  553.   IHeight := FOriginal.Height;
  554.   if FGlyphList = nil then
  555.   begin
  556.     if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
  557.     FGlyphList := GlyphCache.GetList(IWidth, IHeight);
  558.   end;
  559.   TmpImage := TBitmap.Create;
  560.   try
  561. { Regressed RR
  562.     TmpImage.Assign(FOriginal);
  563. }
  564.     TmpImage.Width := IWidth;
  565.     TmpImage.Height := IHeight;
  566.     { Use the device-dependant transparent color }
  567. { Regressed RR
  568.     TmpImage.HandleType := bmDDB;
  569.     FTransparentColor := TmpImage.TransparentColor;
  570. }    
  571.     IRect := Rect(0, 0, IWidth, IHeight);
  572.     TmpImage.Canvas.Brush.Color := clBtnFace;
  573.     I := State;
  574.     if Ord(I) >= NumGlyphs then I := bsUp;
  575.     ORect := Rect(Ord(I) * IWidth, 0, (Ord(I) + 1) * IWidth, IHeight);
  576.     case State of
  577.       bsUp, bsDown:
  578.         begin
  579.           TmpImage.Canvas.BrushCopy(IRect, FOriginal, ORect, FTransparentColor);
  580.           FIndexs[State] := FGlyphList.Add(TmpImage, nil);
  581.         end;
  582.       bsExclusive:
  583.         begin
  584.           TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);
  585.           FIndexs[State] := FGlyphList.AddMasked(TmpImage, FTransparentColor);
  586.         end;
  587.  
  588.       bsDisabled:
  589.         begin
  590.           MonoBmp := nil;
  591.           DDB := nil;
  592.           try
  593.             MonoBmp := TBitmap.Create;
  594.             DDB := TBitmap.Create;
  595.             DDB.Assign(FOriginal);
  596.             DDB.HandleType := bmDDB;
  597.             if NumGlyphs > 1 then
  598.             with TmpImage.Canvas do
  599.             begin    { Change white & gray to clBtnHighlight and clBtnShadow }
  600.               CopyRect(IRect, DDB.Canvas, ORect);
  601.               MonoBmp.Monochrome := True;
  602.               MonoBmp.Width := IWidth;
  603.               MonoBmp.Height := IHeight;
  604.  
  605.               { Convert white to clBtnHighlight }
  606.               DDB.Canvas.Brush.Color := clWhite;
  607.               MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
  608.               Brush.Color := clBtnHighlight;
  609.               DestDC := Handle;
  610.               SetTextColor(DestDC, clBlack);
  611.               SetBkColor(DestDC, clWhite);
  612.               BitBlt(DestDC, 0, 0, IWidth, IHeight,
  613.                      MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
  614.  
  615.               { Convert gray to clBtnShadow }
  616.               DDB.Canvas.Brush.Color := clGray;
  617.               MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
  618.               Brush.Color := clBtnShadow;
  619.               DestDC := Handle;
  620.               SetTextColor(DestDC, clBlack);
  621.               SetBkColor(DestDC, clWhite);
  622.               BitBlt(DestDC, 0, 0, IWidth, IHeight,
  623.                      MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
  624.  
  625.               { Convert transparent color to clBtnFace }
  626.               DDB.Canvas.Brush.Color := ColorToRGB(FTransparentColor);
  627.               MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
  628.               Brush.Color := clBtnFace;
  629.               DestDC := Handle;
  630.               SetTextColor(DestDC, clBlack);
  631.               SetBkColor(DestDC, clWhite);
  632.               BitBlt(DestDC, 0, 0, IWidth, IHeight,
  633.                      MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
  634.             end
  635.             else
  636.             begin
  637.               { Create a disabled version }
  638.               with MonoBmp do
  639.               begin
  640.                 Assign(FOriginal);
  641.                 HandleType := bmDDB;
  642.                 Canvas.Brush.Color := clBlack;
  643.                 Width := IWidth;
  644.                 if Monochrome then
  645.                 begin
  646.                   Canvas.Font.Color := clWhite;
  647.                   Monochrome := False;
  648.                   Canvas.Brush.Color := clWhite;
  649.                 end;
  650.                 Monochrome := True;
  651.               end;
  652.               with TmpImage.Canvas do
  653.               begin
  654.                 Brush.Color := clBtnFace;
  655.                 FillRect(IRect);
  656.                 Brush.Color := clBtnHighlight;
  657.                 SetTextColor(Handle, clBlack);
  658.                 SetBkColor(Handle, clWhite);
  659.                 BitBlt(Handle, 1, 1, IWidth, IHeight,
  660.                   MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
  661.                 Brush.Color := clBtnShadow;
  662.                 SetTextColor(Handle, clBlack);
  663.                 SetBkColor(Handle, clWhite);
  664.                 BitBlt(Handle, 0, 0, IWidth, IHeight,
  665.                   MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
  666.               end;
  667.             end;
  668.             FIndexs[State] := FGlyphList.Add(TmpImage, nil);
  669.           finally
  670.             DDB.Free;
  671.             MonoBmp.Free;
  672.           end;
  673.         end;
  674.  
  675.     end;
  676.   finally
  677.     TmpImage.Free;
  678.   end;
  679.   Result := FIndexs[State];
  680.   FOriginal.Dormant;
  681. end;
  682.  
  683. procedure TButtonGlyph.DrawButtonGlyph(Canvas: TCanvas; X, Y: Integer;
  684.   State: TButtonState);
  685. var
  686.   Index: Integer;
  687. begin
  688.   if FOriginal = nil then Exit;
  689.   if (FOriginal.Width = 0) or (FOriginal.Height = 0) then Exit;
  690.   Index := CreateButtonGlyph(State);
  691.   if State = bsExclusive then
  692.     ImageList_DrawEx(FGlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0,
  693.       clNone, clNone, ILD_Transparent)
  694.   else
  695.     ImageList_DrawEx(FGlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0,
  696.       ColorToRGB(clBtnFace), clNone, ILD_Normal);
  697. end;
  698.  
  699. procedure TButtonGlyph.DrawButtonText(Canvas: TCanvas; const Caption: string;
  700.   TextBounds: TRect; State: TButtonState);
  701. begin
  702.   with Canvas do
  703.   begin
  704.     Brush.Style := bsClear;
  705.     if State = bsDisabled then
  706.     begin
  707.       OffsetRect(TextBounds, 1, 1);
  708.       Font.Color := clBtnFace;
  709.       DrawText(Handle, PChar(Caption), Length(Caption), TextBounds, 0);
  710.       OffsetRect(TextBounds, -1, -1);
  711.       Font.Color := clBtnShadow;
  712.       DrawText(Handle, PChar(Caption), Length(Caption), TextBounds, 0);
  713.     end else
  714.       DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,
  715.         DT_CENTER or DT_VCENTER or DT_SINGLELINE);
  716.   end;
  717. end;
  718.  
  719. procedure TButtonGlyph.CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
  720.   const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
  721.   var GlyphPos: TPoint; var TextBounds: TRect);
  722. var
  723.   TextPos: TPoint;
  724.   ClientSize, GlyphSize, TextSize: TPoint;
  725.   TotalSize: TPoint;
  726. begin
  727.   { calculate the item sizes }
  728.   ClientSize := Point(Client.Right - Client.Left, Client.Bottom -
  729.     Client.Top);
  730.  
  731.   if FOriginal <> nil then
  732.     GlyphSize := Point(FOriginal.Width div FNumGlyphs, FOriginal.Height) else
  733.     GlyphSize := Point(0, 0);
  734.  
  735.   if Length(Caption) > 0 then
  736.   begin
  737.     TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
  738.     DrawText(Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, DT_CALCRECT);
  739.     TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom -
  740.       TextBounds.Top);
  741.   end
  742.   else
  743.   begin
  744.     TextBounds := Rect(0, 0, 0, 0);
  745.     TextSize := Point(0,0);
  746.   end;
  747.  
  748.   { If the layout has the glyph on the right or the left, then both the
  749.     text and the glyph are centered vertically.  If the glyph is on the top
  750.     or the bottom, then both the text and the glyph are centered horizontally.}
  751.   if Layout in [blGlyphLeft, blGlyphRight] then
  752.   begin
  753.     GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2;
  754.     TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;
  755.   end
  756.   else
  757.   begin
  758.     GlyphPos.X := (ClientSize.X - GlyphSize.X + 1) div 2;
  759.     TextPos.X := (ClientSize.X - TextSize.X + 1) div 2;
  760.   end;
  761.  
  762.   { if there is no text or no bitmap, then Spacing is irrelevant }
  763.   if (TextSize.X = 0) or (GlyphSize.X = 0) then
  764.     Spacing := 0;
  765.  
  766.   { adjust Margin and Spacing }
  767.   if Margin = -1 then
  768.   begin
  769.     if Spacing = -1 then
  770.     begin
  771.       TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);
  772.       if Layout in [blGlyphLeft, blGlyphRight] then
  773.         Margin := (ClientSize.X - TotalSize.X) div 3
  774.       else
  775.         Margin := (ClientSize.Y - TotalSize.Y) div 3;
  776.       Spacing := Margin;
  777.     end
  778.     else
  779.     begin
  780.       TotalSize := Point(GlyphSize.X + Spacing + TextSize.X, GlyphSize.Y +
  781.         Spacing + TextSize.Y);
  782.       if Layout in [blGlyphLeft, blGlyphRight] then
  783.         Margin := (ClientSize.X - TotalSize.X + 1) div 2
  784.       else
  785.         Margin := (ClientSize.Y - TotalSize.Y + 1) div 2;
  786.     end;
  787.   end
  788.   else
  789.   begin
  790.     if Spacing = -1 then
  791.     begin
  792.       TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X), ClientSize.Y -
  793.         (Margin + GlyphSize.Y));
  794.       if Layout in [blGlyphLeft, blGlyphRight] then
  795.         Spacing := (TotalSize.X - TextSize.X) div 2
  796.       else
  797.         Spacing := (TotalSize.Y - TextSize.Y) div 2;
  798.     end;
  799.   end;
  800.  
  801.   case Layout of
  802.     blGlyphLeft:
  803.       begin
  804.         GlyphPos.X := Margin;
  805.         TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;
  806.       end;
  807.     blGlyphRight:
  808.       begin
  809.         GlyphPos.X := ClientSize.X - Margin - GlyphSize.X;
  810.         TextPos.X := GlyphPos.X - Spacing - TextSize.X;
  811.       end;
  812.     blGlyphTop:
  813.       begin
  814.         GlyphPos.Y := Margin;
  815.         TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;
  816.       end;
  817.     blGlyphBottom:
  818.       begin
  819.         GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;
  820.         TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;
  821.       end;
  822.   end;
  823.  
  824.   { fixup the result variables }
  825.   Inc(GlyphPos.X, Client.Left);
  826.   Inc(GlyphPos.Y, Client.Top);
  827.   OffsetRect(TextBounds, TextPos.X + Client.Left, TextPos.Y + Client.Top);
  828. end;
  829.  
  830. function TButtonGlyph.Draw(Canvas: TCanvas; const Client: TRect;
  831.   const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
  832.   State: TButtonState): TRect;
  833. var
  834.   GlyphPos: TPoint;
  835. begin
  836.   CalcButtonLayout(Canvas, Client, Caption, Layout, Margin, Spacing,
  837.     GlyphPos, Result);
  838.   DrawButtonGlyph(Canvas, GlyphPos.X, GlyphPos.Y, State);
  839.   DrawButtonText(Canvas, Caption, Result, State);
  840. end;
  841.  
  842. { TSpeedButton }
  843. constructor TSpeedButton.Create(AOwner: TComponent);
  844. begin
  845.   inherited Create(AOwner);
  846.   SetBounds(0, 0, 25, 25);
  847.   ControlStyle := [csCaptureMouse, csOpaque, csDoubleClicks];
  848.   FGlyph := TButtonGlyph.Create;
  849.   TButtonGlyph(FGlyph).OnChange := GlyphChanged;
  850.   ParentFont := True;
  851.   FSpacing := 4;
  852.   FMapColors := True;
  853.   FMargin := -1;
  854.   FLayout := blGlyphLeft;
  855.   Inc(ButtonCount);
  856. end;
  857.  
  858. destructor TSpeedButton.Destroy;
  859. begin
  860.   TButtonGlyph(FGlyph).Free;
  861.   Dec(ButtonCount);
  862.   if ButtonCount = 0 then
  863.   begin
  864.     Pattern.Free;
  865.     Pattern := nil;
  866.   end;
  867.   inherited Destroy;
  868. end;
  869.  
  870. procedure TSpeedButton.Paint;
  871. var
  872.   PaintRect: TRect;
  873.   DrawFlags: Integer;
  874. begin
  875.   if not Enabled and not (csDesigning in ComponentState) then
  876.   begin
  877.     FState := bsDisabled;
  878.     FDragging := False;
  879.   end
  880.   else if FState = bsDisabled then
  881.     if FDown and (GroupIndex <> 0) then
  882.       FState := bsExclusive
  883.     else
  884.       FState := bsUp;
  885.  
  886.   Canvas.Font := Self.Font;
  887.  
  888.   PaintRect := Rect(0, 0, Width, Height);
  889.  
  890.   if not FFlat then
  891.   begin
  892.     DrawFlags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
  893.     if FState in [bsDown, bsExclusive] then
  894.       DrawFlags := DrawFlags or DFCS_PUSHED;
  895.     DrawFrameControl(Canvas.Handle, PaintRect, DFC_BUTTON, DrawFlags);
  896.   end
  897.   else
  898.   begin
  899.     Canvas.Brush.Color := clBtnFace;
  900.     if FMouseInControl then
  901.     begin
  902.       if FState in [bsDown, bsExclusive] then Canvas.Pen.Color := clBtnShadow
  903.       else Canvas.Pen.Color := clBtnHighlight;
  904.     end
  905.     else Canvas.Pen.Color := clBtnFace;
  906.     Canvas.Rectangle(PaintRect.Left, PaintRect.Top, PaintRect.Right,
  907.       PaintRect.Bottom);
  908.     if FMouseInControl then
  909.     begin
  910.       if FState in [bsDown, bsExclusive] then Canvas.Pen.Color := clBtnHighlight
  911.       else Canvas.Pen.Color := clBtnShadow;
  912.       Canvas.PolyLine([
  913.         Point(PaintRect.Left, PaintRect.Bottom - 1),
  914.         Point(PaintRect.Right - 1, PaintRect.Bottom - 1),
  915.         Point(PaintRect.Right - 1, PaintRect.Top - 1)
  916.         ]);
  917.     end;
  918.   end;
  919.  
  920.   if FState in [bsDown, bsExclusive] then
  921.     OffsetRect(PaintRect, 1, 1);
  922.  
  923.   if (FState = bsExclusive) and (not FFlat or not FMouseInControl) then
  924.   begin
  925.     if Pattern = nil then CreateBrushPattern;
  926.     Canvas.Brush.Bitmap := Pattern;
  927.     Canvas.FillRect(PaintRect);
  928.   end;
  929.  
  930.   TButtonGlyph(FGlyph).Draw(Canvas, PaintRect, Caption, FLayout, FMargin, FSpacing,
  931.     FState);
  932.   if FFlat and (FState in [bsDown, bsExclusive]) then
  933.   begin
  934.     Canvas.Pen.Color := clBtnShadow;
  935.     Canvas.PolyLine([Point(0, Height), Point(0, 0), Point(Width, 0)]);
  936.     Canvas.Pen.Color := clBtnHighlight;
  937.     Canvas.PolyLine([Point(0, Height - 1), Point(Width - 1, Height - 1),
  938.       Point(Width - 1, -1)]);
  939.   end;
  940.  
  941.   if FFlat and (csDesigning in ComponentState) then
  942.   begin
  943.     Canvas.Pen.Color := clWindowFrame;
  944.     Canvas.Pen.Style := psDot;
  945.     Canvas.Brush.Style := bsClear;
  946.     Canvas.Rectangle(ClientRect.Left, ClientRect.Top, ClientRect.Right,
  947.       ClientRect.Bottom);
  948.   end;
  949. end;
  950.  
  951. procedure TSpeedButton.UpdateTracking;
  952. var
  953.   P: TPoint;
  954. begin
  955.   if FFlat then
  956.   begin
  957.     GetCursorPos(P);
  958.     FMouseInControl := Enabled and (FindDragTarget(P, True) = Self);
  959.   end;
  960. end;
  961.  
  962. procedure TSpeedButton.Loaded;
  963. var
  964.   State: TButtonState;
  965. begin
  966.   inherited Loaded;
  967.   if Enabled then
  968.     State := bsUp
  969.   else
  970.     State := bsDisabled;
  971.   TButtonGlyph(FGlyph).CreateButtonGlyph(State);
  972. end;
  973.  
  974. procedure TSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  975.   X, Y: Integer);
  976. begin
  977.   inherited MouseDown(Button, Shift, X, Y);
  978.   if (Button = mbLeft) and Enabled then
  979.   begin
  980.     if not FDown then
  981.     begin
  982.       FState := bsDown;
  983.       Repaint;
  984.     end;
  985.     FDragging := True;
  986.   end;
  987. end;
  988.  
  989. procedure TSpeedButton.MouseMove(Shift: TShiftState; X, Y: Integer);
  990. var
  991.   NewState: TButtonState;
  992. begin
  993.   inherited MouseMove(Shift, X, Y);
  994.   if FDragging then
  995.   begin
  996.     if not FDown then NewState := bsUp
  997.     else NewState := bsExclusive;
  998.     if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
  999.       if FDown then NewState := bsExclusive else NewState := bsDown;
  1000.     if NewState <> FState then
  1001.     begin
  1002.       FState := NewState;
  1003.       Repaint;
  1004.     end;
  1005.   end;
  1006. end;
  1007.  
  1008. procedure TSpeedButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  1009.   X, Y: Integer);
  1010. var
  1011.   DoClick: Boolean;
  1012. begin
  1013.   inherited MouseUp(Button, Shift, X, Y);
  1014.   if FDragging then
  1015.   begin
  1016.     FDragging := False;
  1017.     DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
  1018.     if FGroupIndex = 0 then
  1019.     begin
  1020.       { Redraw face in-case mouse is captured }
  1021.       FState := bsUp;
  1022.       FMouseInControl := False;
  1023.       if not (FState in [bsExclusive, bsDown]) then Repaint;
  1024.     end
  1025.     else
  1026.       if DoClick then SetDown(not FDown)
  1027.       else
  1028.       begin
  1029.         if FDown then FState := bsExclusive;
  1030.         Repaint;
  1031.       end;
  1032.     if DoClick then Click;
  1033.     UpdateTracking;
  1034.     Invalidate;
  1035.   end;
  1036. end;
  1037.  
  1038. procedure TSpeedButton.Click;
  1039. begin
  1040.   inherited Click;
  1041. end;
  1042.  
  1043. function TSpeedButton.GetPalette: HPALETTE;
  1044. begin
  1045.   Result := Glyph.Palette;
  1046. end;
  1047.  
  1048. function TSpeedButton.GetGlyph: TBitmap;
  1049. begin
  1050.   Result := TButtonGlyph(FGlyph).Glyph;
  1051. end;
  1052.  
  1053. procedure TSpeedButton.SetGlyph(Value: TBitmap);
  1054. begin
  1055.   TButtonGlyph(FGlyph).Glyph := Value;
  1056.   Invalidate;
  1057. end;
  1058.  
  1059. function TSpeedButton.GetNumGlyphs: TNumGlyphs;
  1060. begin
  1061.   Result := TButtonGlyph(FGlyph).NumGlyphs;
  1062. end;
  1063.  
  1064. procedure TSpeedButton.SetNumGlyphs(Value: TNumGlyphs);
  1065. begin
  1066.   if Value < 0 then Value := 1
  1067.   else if Value > 4 then Value := 4;
  1068.   if Value <> TButtonGlyph(FGlyph).NumGlyphs then
  1069.   begin
  1070.     TButtonGlyph(FGlyph).NumGlyphs := Value;
  1071.     Invalidate;
  1072.   end;
  1073. end;
  1074.  
  1075. procedure TSpeedButton.GlyphChanged(Sender: TObject);
  1076. begin
  1077.   Invalidate;
  1078. end;
  1079.  
  1080. procedure TSpeedButton.UpdateExclusive;
  1081. var
  1082.   Msg: TMessage;
  1083. begin
  1084.   if (FGroupIndex <> 0) and (Parent <> nil) then
  1085.   begin
  1086.     Msg.Msg := CM_BUTTONPRESSED;
  1087.     Msg.WParam := FGroupIndex;
  1088.     Msg.LParam := Longint(Self);
  1089.     Msg.Result := 0;
  1090.     Parent.Broadcast(Msg);
  1091.   end;
  1092. end;
  1093.  
  1094. procedure TSpeedButton.SetDown(Value: Boolean);
  1095. begin
  1096.   if FGroupIndex = 0 then Value := False;
  1097.   if Value <> FDown then
  1098.   begin
  1099.     if FDown and (not FAllowAllUp) then Exit;
  1100.     FDown := Value;
  1101.     if Value then
  1102.     begin
  1103.       if FState = bsUp then Invalidate;
  1104.       FState := bsExclusive
  1105.     end
  1106.     else
  1107.     begin
  1108.       FState := bsUp;
  1109.       Invalidate;
  1110.     end;
  1111.     if Value then UpdateExclusive;
  1112.   end;
  1113. end;
  1114.  
  1115. procedure TSpeedButton.SetFlat(Value: Boolean);
  1116. begin
  1117.   if Value <> FFlat then
  1118.   begin
  1119.     FFlat := Value;
  1120.     Invalidate;
  1121.   end;
  1122. end;
  1123.  
  1124. procedure TSpeedButton.SetGroupIndex(Value: Integer);
  1125. begin
  1126.   if FGroupIndex <> Value then
  1127.   begin
  1128.     FGroupIndex := Value;
  1129.     UpdateExclusive;
  1130.   end;
  1131. end;
  1132.  
  1133. procedure TSpeedButton.SetLayout(Value: TButtonLayout);
  1134. begin
  1135.   if FLayout <> Value then
  1136.   begin
  1137.     FLayout := Value;
  1138.     Invalidate;
  1139.   end;
  1140. end;
  1141.  
  1142. procedure TSpeedButton.SetMargin(Value: Integer);
  1143. begin
  1144.   if (Value <> FMargin) and (Value >= -1) then
  1145.   begin
  1146.     FMargin := Value;
  1147.     Invalidate;
  1148.   end;
  1149. end;
  1150.  
  1151. procedure TSpeedButton.SetSpacing(Value: Integer);
  1152. begin
  1153.   if Value <> FSpacing then
  1154.   begin
  1155.     FSpacing := Value;
  1156.     Invalidate;
  1157.   end;
  1158. end;
  1159.  
  1160. procedure TSpeedButton.SetAllowAllUp(Value: Boolean);
  1161. begin
  1162.   if FAllowAllUp <> Value then
  1163.   begin
  1164.     FAllowAllUp := Value;
  1165.     UpdateExclusive;
  1166.   end;
  1167. end;
  1168.  
  1169. procedure TSpeedButton.WMLButtonDblClk(var Message: TWMLButtonDown);
  1170. begin
  1171.   inherited;
  1172.   if FDown then DblClick;
  1173. end;
  1174.  
  1175. procedure TSpeedButton.CMEnabledChanged(var Message: TMessage);
  1176. const
  1177.   NewState: array[Boolean] of TButtonState = (bsDisabled, bsUp);
  1178. begin
  1179.   TButtonGlyph(FGlyph).CreateButtonGlyph(NewState[Enabled]);
  1180.   UpdateTracking;
  1181.   Invalidate;
  1182. end;
  1183.  
  1184. procedure TSpeedButton.CMButtonPressed(var Message: TMessage);
  1185. var
  1186.   Sender: TSpeedButton;
  1187. begin
  1188.   if Message.WParam = FGroupIndex then
  1189.   begin
  1190.     Sender := TSpeedButton(Message.LParam);
  1191.     if Sender <> Self then
  1192.     begin
  1193.       if Sender.Down and FDown then
  1194.       begin
  1195.         FDown := False;
  1196.         FState := bsUp;
  1197.         Invalidate;
  1198.       end;
  1199.       FAllowAllUp := Sender.AllowAllUp;
  1200.     end;
  1201.   end;
  1202. end;
  1203.  
  1204. procedure TSpeedButton.CMDialogChar(var Message: TCMDialogChar);
  1205. begin
  1206.   with Message do
  1207.     if IsAccel(CharCode, Caption) and Enabled then
  1208.     begin
  1209.       Click;
  1210.       Result := 1;
  1211.     end else
  1212.       inherited;
  1213. end;
  1214.  
  1215. procedure TSpeedButton.CMFontChanged(var Message: TMessage);
  1216. begin
  1217.   Invalidate;
  1218. end;
  1219.  
  1220. procedure TSpeedButton.CMTextChanged(var Message: TMessage);
  1221. begin
  1222.   Invalidate;
  1223. end;
  1224.  
  1225. procedure TSpeedButton.CMSysColorChange(var Message: TMessage);
  1226. begin
  1227.   with TButtonGlyph(FGlyph) do
  1228.   begin
  1229.     Invalidate;
  1230.     CreateButtonGlyph(FState);
  1231.   end;
  1232. end;
  1233.  
  1234. procedure TSpeedButton.CMMouseEnter(var Message: TMessage);
  1235. begin
  1236.   inherited;
  1237.   if not ForegroundTask then Exit;
  1238.   if FFlat and (not FMouseInControl) and Enabled then
  1239.   begin
  1240.     FMouseInControl := True;
  1241.     Invalidate;
  1242.   end;
  1243. end;
  1244.  
  1245. procedure TSpeedButton.CMMouseLeave(var Message: TMessage);
  1246. begin
  1247.   inherited;
  1248.   if FFlat and FMouseInControl and Enabled then
  1249.   begin
  1250.     FMouseInControl := False;
  1251.     Invalidate;
  1252.   end;
  1253. end;
  1254.  
  1255. { TBitBtn }
  1256.  
  1257. constructor TBitBtn.Create(AOwner: TComponent);
  1258. begin
  1259.   inherited Create(AOwner);
  1260.   FGlyph := TButtonGlyph.Create;
  1261.   TButtonGlyph(FGlyph).OnChange := GlyphChanged;
  1262.   FCanvas := TCanvas.Create;
  1263.   FStyle := bsAutoDetect;
  1264.   FKind := bkCustom;
  1265.   FLayout := blGlyphLeft;
  1266.   FSpacing := 4;
  1267.   FMargin := -1;
  1268. end;
  1269.  
  1270. destructor TBitBtn.Destroy;
  1271. begin
  1272.   inherited Destroy;
  1273.   TButtonGlyph(FGlyph).Free;
  1274.   FCanvas.Free;
  1275. end;
  1276.  
  1277. procedure TBitBtn.CreateHandle;
  1278. var
  1279.   State: TButtonState;
  1280. begin
  1281.   if Enabled then
  1282.     State := bsUp
  1283.   else
  1284.     State := bsDisabled;
  1285.   inherited CreateHandle;
  1286.   TButtonGlyph(FGlyph).CreateButtonGlyph(State);
  1287. end;
  1288.  
  1289. procedure TBitBtn.CreateParams(var Params: TCreateParams);
  1290. begin
  1291.   inherited CreateParams(Params);
  1292.   with Params do Style := Style or BS_OWNERDRAW;
  1293. end;
  1294.  
  1295. procedure TBitBtn.SetButtonStyle(ADefault: Boolean);
  1296. begin
  1297.   if ADefault <> IsFocused then
  1298.   begin
  1299.     IsFocused := ADefault;
  1300.     Refresh;
  1301.   end;
  1302. end;
  1303.  
  1304. procedure TBitBtn.Click;
  1305. var
  1306.   Form: TCustomForm;
  1307.   Control: TWinControl;
  1308. begin
  1309.   case FKind of
  1310.     bkClose:
  1311.       begin
  1312.         Form := GetParentForm(Self);
  1313.         if Form <> nil then Form.Close
  1314.         else inherited Click;
  1315.       end;
  1316.     bkHelp:
  1317.       begin
  1318.         Control := Self;
  1319.         while (Control <> nil) and (Control.HelpContext = 0) do
  1320.           Control := Control.Parent;
  1321.         if Control <> nil then Application.HelpContext(Control.HelpContext)
  1322.         else inherited Click;
  1323.       end;
  1324.     else
  1325.       inherited Click;
  1326.   end;
  1327. end;
  1328.  
  1329. procedure TBitBtn.CNMeasureItem(var Message: TWMMeasureItem);
  1330. begin
  1331.   with Message.MeasureItemStruct^ do
  1332.   begin
  1333.     itemWidth := Width;
  1334.     itemHeight := Height;
  1335.   end;
  1336. end;
  1337.  
  1338. procedure TBitBtn.CNDrawItem(var Message: TWMDrawItem);
  1339. begin
  1340.   DrawItem(Message.DrawItemStruct^);
  1341. end;
  1342.  
  1343. procedure TBitBtn.DrawItem(const DrawItemStruct: TDrawItemStruct);
  1344. var
  1345.   IsDown, IsDefault: Boolean;
  1346.   State: TButtonState;
  1347.   R: TRect;
  1348.   Flags: Longint;
  1349. begin
  1350.   FCanvas.Handle := DrawItemStruct.hDC;
  1351.   R := ClientRect;
  1352.  
  1353.   with DrawItemStruct do
  1354.   begin
  1355.     IsDown := itemState and ODS_SELECTED <> 0;
  1356.     IsDefault := itemState and ODS_FOCUS <> 0;
  1357.  
  1358.     if not Enabled then State := bsDisabled
  1359.     else if IsDown then State := bsDown
  1360.     else State := bsUp;
  1361.   end;
  1362.  
  1363.   Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
  1364.   if IsDown then Flags := Flags or DFCS_PUSHED;
  1365.   if DrawItemStruct.itemState and ODS_DISABLED <> 0 then
  1366.     Flags := Flags or DFCS_INACTIVE;
  1367.  
  1368.   { DrawFrameControl doesn't allow for drawing a button as the
  1369.       default button, so it must be done here. }
  1370.   if IsFocused or IsDefault then
  1371.   begin
  1372.     FCanvas.Pen.Color := clWindowFrame;
  1373.     FCanvas.Pen.Width := 1;
  1374.     FCanvas.Brush.Style := bsClear;
  1375.     FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
  1376.  
  1377.     { DrawFrameControl must draw within this border }
  1378.     InflateRect(R, -1, -1);
  1379.   end;
  1380.  
  1381.   { DrawFrameControl does not draw a pressed button correctly }
  1382.   if IsDown then
  1383.   begin
  1384.     FCanvas.Pen.Color := clBtnShadow;
  1385.     FCanvas.Pen.Width := 1;
  1386.     FCanvas.Brush.Color := clBtnFace;
  1387.     FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
  1388.     InflateRect(R, -1, -1);
  1389.   end
  1390.   else
  1391.     DrawFrameControl(DrawItemStruct.hDC, R, DFC_BUTTON, Flags);
  1392.  
  1393.   if IsFocused then
  1394.   begin
  1395.     R := ClientRect;
  1396.     InflateRect(R, -1, -1);
  1397.   end;
  1398.  
  1399.   FCanvas.Font := Self.Font;
  1400.   if IsDown then
  1401.     OffsetRect(R, 1, 1);
  1402.   TButtonGlyph(FGlyph).Draw(FCanvas, R, Caption, FLayout,
  1403.     FMargin, FSpacing, State);
  1404.  
  1405.   if IsFocused then
  1406.   begin
  1407.     R := ClientRect;
  1408.     InflateRect(R, -4, -4);
  1409.     FCanvas.Pen.Color := clWindowFrame;
  1410.     FCanvas.Brush.Color := clBtnFace;
  1411.     DrawFocusRect(FCanvas.Handle, R);
  1412.   end;
  1413.  
  1414.   FCanvas.Handle := 0;
  1415. end;
  1416.  
  1417. procedure TBitBtn.CMFontChanged(var Message: TMessage);
  1418. begin
  1419.   inherited;
  1420.   Invalidate;
  1421. end;
  1422.  
  1423. procedure TBitBtn.CMEnabledChanged(var Message: TMessage);
  1424. begin
  1425.   inherited;
  1426.   Invalidate;
  1427. end;
  1428.  
  1429. procedure TBitBtn.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  1430. begin
  1431.   Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
  1432. end;
  1433.  
  1434. function TBitBtn.GetPalette: HPALETTE;
  1435. begin
  1436.   Result := Glyph.Palette;
  1437. end;
  1438.  
  1439. procedure TBitBtn.SetGlyph(Value: TBitmap);
  1440. begin
  1441.   TButtonGlyph(FGlyph).Glyph := Value as TBitmap;
  1442.   FModifiedGlyph := True;
  1443.   Invalidate;
  1444. end;
  1445.  
  1446. function TBitBtn.GetGlyph: TBitmap;
  1447. begin
  1448.   Result := TButtonGlyph(FGlyph).Glyph;
  1449. end;
  1450.  
  1451. procedure TBitBtn.GlyphChanged(Sender: TObject);
  1452. begin
  1453.   Invalidate;
  1454. end;
  1455.  
  1456. function TBitBtn.IsCustom: Boolean;
  1457. begin
  1458.   Result := Kind = bkCustom;
  1459. end;
  1460.  
  1461. procedure TBitBtn.SetStyle(Value: TButtonStyle);
  1462. begin
  1463.   if Value <> FStyle then
  1464.   begin
  1465.     FStyle := Value;
  1466.     Invalidate;
  1467.   end;
  1468. end;
  1469.  
  1470. procedure TBitBtn.SetKind(Value: TBitBtnKind);
  1471. begin
  1472.   if Value <> FKind then
  1473.   begin
  1474.     if Value <> bkCustom then
  1475.     begin
  1476.       Default := Value in [bkOK, bkYes];
  1477.       Cancel := Value in [bkCancel, bkNo];
  1478.  
  1479.       if ((csLoading in ComponentState) and (Caption = '')) or
  1480.         (not (csLoading in ComponentState)) then
  1481.       begin
  1482.         if BitBtnCaptions[Value] <> '' then
  1483.           Caption := BitBtnCaptions[Value];
  1484.       end;
  1485.  
  1486.       ModalResult := BitBtnModalResults[Value];
  1487.       TButtonGlyph(FGlyph).Glyph := GetBitBtnGlyph(Value);
  1488.       NumGlyphs := 2;
  1489.       FModifiedGlyph := False;
  1490.     end;
  1491.     FKind := Value;
  1492.     Invalidate;
  1493.   end;
  1494. end;
  1495.  
  1496. function TBitBtn.IsCustomCaption: Boolean;
  1497. begin
  1498.   Result := CompareStr(Caption, BitBtnCaptions[FKind]) <> 0;
  1499. end;
  1500.  
  1501. function TBitBtn.GetKind: TBitBtnKind;
  1502. begin
  1503.   if FKind <> bkCustom then
  1504.     if ((FKind in [bkOK, bkYes]) xor Default) or
  1505.       ((FKind in [bkCancel, bkNo]) xor Cancel) or
  1506.       (ModalResult <> BitBtnModalResults[FKind]) or
  1507.       FModifiedGlyph then
  1508.       FKind := bkCustom;
  1509.   Result := FKind;
  1510. end;
  1511.  
  1512. procedure TBitBtn.SetLayout(Value: TButtonLayout);
  1513. begin
  1514.   if FLayout <> Value then
  1515.   begin
  1516.     FLayout := Value;
  1517.     Invalidate;
  1518.   end;
  1519. end;
  1520.  
  1521. function TBitBtn.GetNumGlyphs: TNumGlyphs;
  1522. begin
  1523.   Result := TButtonGlyph(FGlyph).NumGlyphs;
  1524. end;
  1525.  
  1526. procedure TBitBtn.SetNumGlyphs(Value: TNumGlyphs);
  1527. begin
  1528.   if Value < 0 then Value := 1
  1529.   else if Value > 4 then Value := 4;
  1530.   if Value <> TButtonGlyph(FGlyph).NumGlyphs then
  1531.   begin
  1532.     TButtonGlyph(FGlyph).NumGlyphs := Value;
  1533.     Invalidate;
  1534.   end;
  1535. end;
  1536.  
  1537. procedure TBitBtn.SetSpacing(Value: Integer);
  1538. begin
  1539.   if FSpacing <> Value then
  1540.   begin
  1541.     FSpacing := Value;
  1542.     Invalidate;
  1543.   end;
  1544. end;
  1545.  
  1546. procedure TBitBtn.SetMargin(Value: Integer);
  1547. begin
  1548.   if (Value <> FMargin) and (Value >= - 1) then
  1549.   begin
  1550.     FMargin := Value;
  1551.     Invalidate;
  1552.   end;
  1553. end;
  1554.  
  1555. procedure DestroyLocals; far;
  1556. var
  1557.   I: TBitBtnKind;
  1558. begin
  1559.   for I := Low(TBitBtnKind) to High(TBitBtnKind) do
  1560.     BitBtnGlyphs[I].Free;
  1561. end;
  1562.  
  1563. initialization
  1564.   FillChar(BitBtnGlyphs, SizeOf(BitBtnGlyphs), 0);
  1565. finalization
  1566.   DestroyLocals;
  1567. end.
  1568.